perm filename QFUNC.F4[MUS,LCS] blob sn#102043 filedate 1974-05-10 generic text, type T, neo UTF8
00100		COMMON XS(100),YS(100),N,X1(512),Y1(512),S(100),K
00200		COMMON/RD/TM(50),SP1(50),SP2(50),SFAC(512)
00220		DIMENSION A(50,2)
00300	21	FORMAT(' F=FINISH  - '$)
00400	26	FORMAT(I3,') TYPE X# AND Y# - OR L=LTPEN.  X=EXIT-- '$)
00500	280	FORMAT(' "A" IS AT -10,10'/)
00600	30	FORMAT(8F)
00700	37	FORMAT(8F9.3)
00800	371	FORMAT(I3,') ',4F8.2)
00900	40	FORMAT(A1)
01000	47	FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
01100	2281	TYPE 280
01200	281	KZ=0
01300		ICUR=0
01400	C   USED IN RELATIVE VECTOR ROUTINE
01500	1032	CALL ZERO(FUNC)
01600	C  CLEARS THE FUNC.
01700		ISMOO=0
01800		GO TO 900
01900	210	KZ=KT
02000		Z=1
02100		GO TO 1032
02200	
02300	900	CALL DPYQ
02400	800	X=0
02500		JT=2
02600	C  JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
02700		Y=0
02800		KT=1
02900		N=-256
03000		CALL DPYBRT(5)
03100	504	IF(KT.GE.KZ)GO TO 510
03200		AMP=A(KT,1)
03300	5008	STEP=A(KT,2)
03400	C   SO IT CAN'T GO BACKWARDS
03500		GO TO 5071
03600	434	ICUR=0
03700		CALL CLRCUR
03800		GO TO 510
03900	C   EXIT FROM CURSOR
04000	CC431	CALL SETCUR(0,0,0)
04100	431	NX=0
04200		NY=0
04300		NZ=0
04400	C  TYPE <CR> HERE TO SET FIRST POINT AT 0,0
04500		ICUR=-1
04600	433	CALL SETCUR(NX,NY,NZ)
04700		NZ=1
04800	C  =1 TO DRAG ALONG VECTOR
04900		TYPE 432,KT
05000		ACCEPT 40,AB
05100		IF(AB.EQ.'B')GO TO 509
05200		IF(AB.EQ.'R')GO TO 434
05300		IF(AB.EQ.'X')GO TO 7000
05400		MX=NX
05500		MY=NY
05600		CALL RDCUR(NX,NY)
05700	CC	CALL SETCUR(NX,NY,1)
05800		STEP=NY/10.
05900		AMP=NX/10.
06000	5571	TYPE 37,AMP,STEP
06100		GO TO 5071
06200	611	FORMAT(' NO MORE THAN 50 SEGS'/)
06300	610	TYPE 611
06400	509	KT=KT-1
06500	CC	IF(ICUR)CALL SETCUR(MX,MY,1)
06600	5091	IF(KT.LT.1)GO TO 281
06700		GO TO 210
06800	432	FORMAT(I3,') <CR>=SEG, B=BACKUP, R=RETURN  '/)
06900	510	IF(ICUR)GO TO 433
07000		TYPE 26,KT
07100		KZ=0
07200		ACCEPT 40,BU
07300		IF(BU.EQ.'B')GO TO 509
07400		IF(BU.EQ.'L')GO TO 431
07500	61	REREAD 30,AMP,STEP,H
07600		IF(BU.EQ.'J')H=-1
07700	C  IF H≠0 THEN JUMP
07800	C**********
07900		IF(BU.EQ.'X')GO TO 7000
08000	C******************
08100	5071	IF(KT.GT.50)GO TO 610
08200	C   TOO MANY SEGS
08300		IF(Z.GT.0)TYPE 371,KT,AMP,STEP
08400		DIF=AMP-Y
08500	C   SO IT CAN'T BACKUP HERE
08600	203	YSTP=STEP
08700	1203	JJX=X*10.
08800		NY=YSTP*10.
08900		NX=AMP*10.
09000		IF(KT.GT.1)GO TO 1202
09100		CALL AIVECT(NX,NY)
09200		GO TO 12
09300	1202	IZ=Y*10.
09400		CALL ALINE(JJX,IZ,NX,NY)
09500		CALL DPYOUT(1)
09600	12	X=AMP
09700		Y=YSTP
09800		A(KT,1)=X
09900	CC	A(KT,2)=X
10000		A(KT,2)=STEP
10100	7001	KT=KT+1
10200	C   KT COUNTS SEGMENTS
10300		GO TO 504
10400	
10500	CC*************7000	IF(ISMOO)GO TO 201
10600	7000	IF(KT.LE.20)GO TO 7007
10700		TYPE 7008
10800		GO TO 509
10900	7008	FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
11000	7007	J=KT-1
11100		CALL CLRCUR
11200		KX=0
11300		JL=0
11400		INC=4
11500		DO 1 K=1,J
11600		KXS=KXS+1
11700		XS(KXS)=A(K,1)
11800	1	YS(KXS)=A(K,2)
11900	9	XS(KXS+1)=999.
12000	4	N=KXS
12100		CALL SS
12200		JL=JL+1
12300		JK=JL
12400		CALL AIVECT(IFIX(XS(1)*10.),IFIX(YS(1)*10.))
12500		DO 5 K=2,512,INC
13000	5	CALL AVECT(IFIX(X1(K)*10.),IFIX(10.*Y1(K)))
13100	7009	CALL DPYOUT(1)
13200		CALL SPEED(X)
13300		IF(X)GO TO 509
15800	CC161	TYPE 21
15900	CC	ACCEPT 40,K
16100	CC	IF(K.EQ.'F')GO TO 2
16200	C  FOR CHANGES
16300	3	IF(K.EQ.'B')GO TO 509
16400	2	CALL CLRCUR
16500		CALL QUADO
16600	CC	GO TO 24
16800		GO TO 509
16900	C  BACKS UP OUT OF SUBROUTINES.
17000		END